PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/dgsay.exe/DGSTR.PAS

Pascal/Delphi Source File | 1989-06-29 | 22.2 KB | 791 lines

{
 ╔═════════════════════════════════════════════════════════════════════════╗
 ║                                                                         ║
 ║        TITLE :      DGSTR.TPU,  Version 8907.01                         ║
 ║      PURPOSE :      String Object and String Handling Routines          ║
 ║       AUTHOR :      David Gerrold, CompuServe ID:  70307,544            ║
 ║  _____________________________________________________________________  ║
 ║                                                                         ║
 ║   Written in Turbo Pascal, Version 5.5,                                 ║
 ║   with routines from Turbo Professional, Version 5.0.                   ║
 ║                                                                         ║
 ║   Turbo Pascal is a product of Borland International.                   ║
 ║   Turbo Professional is a product of TurboPower Software                ║
 ║  _____________________________________________________________________  ║
 ║                                                                         ║
 ║  This is not public domain software.  This is shareware.                ║
 ║  This software is copyright 1989, by David Gerrold.                     ║
 ║                                                                         ║
 ║        The Brass Cannon Corporation                                     ║
 ║        9420 Reseda Blvd., #804                                          ║
 ║        Northridge, CA 91324-2932.                                       ║
 ║                                                                         ║
 ║  If you find this code useful, a donation of $25 is requested --        ║
 ║  not to me, but to the AIDS Project Los Angeles.  Donations may         ║
 ║  be forwarded via the Brass Cannon address.  Thank you.                 ║
 ║                                                                         ║
 ╚═════════════════════════════════════════════════════════════════════════╝
                                                                            }
{ ========================================================================= }
{  Compiler Directives :                                                    }
{ ========================================================================= }

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N+,E+} {Simulate numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}
{$V-}    {Variable range checking off}

{ ========================================================================= }
UNIT DgStr;
{ ========================================================================= }

INTERFACE

USES
  TpString,                                      { Turbo Power unit }
  DgInit;                                        { Dg Initializations }

TYPE
  StrOb = Object (LocOb)
    S : string;

    Procedure  AcceptStr (NewStr : string);
    Procedure  AcceptRaw (RawStr : string);
    Procedure  UpStr;
    Procedure  LoStr;
    Procedure  UpCaseFirstLetter;
    Procedure  TrimLeadCh  (Ch : char);
    Procedure  TrimTrailCh (Ch : char);
    Procedure  TrimCh      (Ch : char);
    Procedure  StripOut    (Ch : char);
    Procedure  OverWrite   (Position : byte;  OverStr : string);
    Procedure  Replace     (OldStr, NewStr : string);
    Procedure  Translate   (OldCh, NewCh : char);
    Procedure  Append      (NewStr : string);
    Procedure  AppendWord  (NewStr : string);
    Procedure  HeadAppend  (NewStr : string);
    Procedure  Compress;
    Procedure  DeCompress;

    Function   L           : byte;
    Function   LastPos     (PosCh : char) : byte;
    Function   SubStr      (Pos1, Pos2 : byte) : string;
    Function   ExtractFirstWord    : string;
    Function   TrimThe             : string;
  end;

{ ========================================================================= }

FUNCTION TrimLeadChars (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning of a string. }

FUNCTION TrimTrailChars (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the end of a string. }

FUNCTION TrimChars (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning and end of a string. }

FUNCTION InCap (Ch : char) : boolean;
{ Returns true if letter is upper case. }

FUNCTION Capitalize (S : string) : string;
{ Capitalizes the first letter in the string. }

FUNCTION CapitalizeAll (S : string) : string;
{ Capitalizes every word in the string. }

PROCEDURE ReplaceOnce (Var S : string;  OldStr, NewStr : string);
{ Finds OldStr in S and replaces it with NewStr. }

PROCEDURE ReplaceAll (Var S : string;  OldStr, NewStr : string);
{ Replaces all occurrences of OldStr with NewStr. }

FUNCTION GetSubStr (S : string; Pos1, Pos2 : byte) : string;
{ Extracts a SubString, starting at Pos1, ending at Pos2. }

FUNCTION Num2Str (Num : extended) : string;
{ Returns any number in shortest possible string. }

FUNCTION Str2Num (S : string) : real;
{ Turns a number in a string into a real number. }

FUNCTION InAlphabet (Ch : char) : boolean;
{ Returns true if ch in Alphabet. }

FUNCTION InNumbers (Ch : char) : boolean;
{ Returns true if ch is a number. }

FUNCTION InApostrophe (Ch : char) : boolean;
{ Returns true if ch is apostrophe. }

FUNCTION InTwoSpacePunctuation (Ch : char) : boolean;
{ Returns true if ch in two space punctuation. }

FUNCTION InPunctuation (Ch : char) : boolean;
{ Returns true if ch in punctuation. }

{ ========================================================================= }
{ ========================================================================= }

IMPLEMENTATION

{ ========================================================================= }

FUNCTION TrimLeadChars (S : string;  Ch : char) : string;
{
  Trims all occurrences of Ch from the beginning of S.
}

VAR
  Len  : byte absolute S;

BEGIN
  While
    (S [1] = Ch) and (Len > 0)                   { while S [1] = Ch }
  do
    begin
    dec (Len);                                   { shorten S }
    move (S [2], S [1], Len);                    { delete 1st char }
    end;
  TrimLeadChars := S;                            { return }
END;

{ ========================================================================= }

FUNCTION TrimTrailChars (S : string;  Ch : char) : string;
{
  Trims all occurrences of Ch from the end of S.
}

VAR
  Len  : byte absolute S;

BEGIN
  While
    (S [Len] = Ch)                               { while last char = Ch }
  do
    dec (Len);                                   { shorten S }
  TrimTrailChars := S;                           { return }
END;

{ ========================================================================= }

FUNCTION TrimChars (S : string;  Ch : char) : string;
{
  Trims all occurrences of Ch from both the beginning and end of S.
}
BEGIN
  TrimChars := TrimTrailChars (TrimLeadChars (S, Ch), Ch);
END;

{ ========================================================================= }

PROCEDURE StrOb.AcceptStr (NewStr : string);
{
  Accept a new string into S.
}
BEGIN
  S := NewStr;
END;

{ ========================================================================= }

PROCEDURE StrOb.AcceptRaw (RawStr : String);
{
  Takes raw variable strings, such as those found in Turbo Pascal code,
  and converts them to standard text strings.

  Will translate #39 into ' and ^E into Ctrl-E, etc.

  Useful for translating text strings from files.  No real
  error-trapping here.  Routine tends to ignore what it doesn't
  understand.  Nevertheless, use with caution.  Make sure input
  strings are valid or results may be unpredictable.
}

VAR
  LenRawStr  : byte absolute RawStr;
  Loop       : byte;
  NumStr     : string [2];
  Trash      : word;
  Ch         : char;

BEGIN
Loop := 1;
S := '';
While
  Loop <= LenRawStr
Do
  Begin
  Case RawStr [Loop] of
    '^' : begin                             { Control Character }
          inc (Loop);
          Ch := Chr (Ord (UpCase (RawStr [Loop])) - 64);
          If (Ch >= #0) and (Ch < #32) then S := S + Ch;
          end;
    '#' : begin                             { Decimal Character }
          inc (Loop);
          NumStr := '';
          While
            (RawStr [Loop] >= '0') and (RawStr [Loop] <= '9')
              and (Loop <= LenRawStr)
          do begin
            NumStr := NumStr + RawStr [Loop];
            Inc (Loop);
            end;
          dec (Loop);
          If Str2Word (NumStr, Trash) then
            S := S + Chr (Trash);
          end;
    #39 : begin                             { Text in single quotes }
          inc (Loop);
          While (RawStr [Loop] <> #39) and (Loop <= LenRawStr) do begin
            S := S + RawStr [Loop];
            inc (Loop);
            end;
          end;
    end; { Case }
  Inc (Loop);
  end;
END;

{ ========================================================================= }

PROCEDURE StrOb.UpStr;
{
  Uppercases the string.
}
BEGIN
  S := StUpCase (S);
END;

{ ========================================================================= }

PROCEDURE StrOb.LoStr;
{
  Lowercases the string.
}
BEGIN
  S := StLoCase (S);
END;

{ ========================================================================= }

FUNCTION InCap (Ch : char) : boolean;            { 8906.01 }
{
  Returns true if Ch is upper case.
}
BEGIN
  InCap := (Ch >= 'A') and (Ch <= 'Z');
END;

{ ========================================================================= }

FUNCTION Capitalize (S : string) : string;       { 8906.01 }
{
  Capitalizes the first letter in the string.
}
BEGIN
  S := StLoCase (S);                             { lower case string }
  S [1] := UpCase (S [1]);                       { upper case first letter }
  Capitalize := S;                               { return }
END;

{ ========================================================================= }

FUNCTION CapitalizeAll (S : string) : string;    { 8906.01 }
{
  Capitalizes the first letter of every word in the string.
}

VAR
  Loop : byte;
  Len  : byte absolute S;

BEGIN
  S := StLoCase (S);                             { lower case string }
  S [1] := UpCase (S [1]);                       { Cap first letter }
  For Loop := 2 to Len do
    If (S [Loop] <> ' ') and (S [pred (Loop)] = ' ') then
      S [Loop] := UpCase (S [Loop]);
  CapitalizeAll := S;
END;

{ ========================================================================= }

PROCEDURE StrOb.UpCaseFirstLetter;               { 8906.01 }
{
  Capitalizes the first letter in the string.
}
BEGIN
  S := Capitalize (S);
END;

{ ========================================================================= }

PROCEDURE StrOb.TrimLeadCh (Ch : char);
{
  Removes all occurrences of Ch from the beginning of S.
}
BEGIN
  S := TrimLeadChars (S, Ch);
END;

{ ========================================================================= }

PROCEDURE StrOb.TrimTrailCh (Ch : char);
{
  Removes all occurrences of Ch from the end of S.
}
BEGIN
  S := TrimTrailChars (S, Ch);
END;

{ ========================================================================= }

PROCEDURE StrOb.TrimCh (Ch : char);
{
  Removes all occurrences of Ch from beginning and end of S.
}
BEGIN
  S := TrimTrailChars (TrimLeadChars (S, Ch), Ch);
END;

{ ========================================================================= }

PROCEDURE StrOb.StripOut (Ch : char);
{
  Strips all occurrences of Ch from S, wheverever they occur.
}

VAR
  Len  : byte absolute S;
  Loop : byte;

BEGIN
  TrimCh (Ch);
  For Loop := Len downto 1 do
    If S [Loop] = Ch then begin
      move (S [succ (Loop)], S [Loop], Len - Loop);
      dec (Len);
      end;
END;

{ ========================================================================= }

PROCEDURE StrOb.OverWrite (Position : byte;  OverStr : string);
{
  Replaces text in S at Position with text in OverStr.

  Although it would be faster to use 'move (OverStr, S, OverStrLen)',
  that method does not correctly manage the length of S.  In specific,
  using move does not allow S to concatenate extra chars if OverStr
  goes beyond its length, nor will move manage the automatic truncation
  of S if it grows beyond 255 chars.
}

VAR
  OverStrLen : byte absolute OverStr;

BEGIN
  delete (S, Position, OverStrLen);              { delete current text }
  insert (OverStr, S, Position);                 { insert new text }
END;

{ ========================================================================= }

PROCEDURE ReplaceOnce (Var S : string;  OldStr, NewStr : string);
{
  Finds first occurrence of OldStr, replaces it with NewStr.
}

VAR
  Position  : byte;
  OldStrLen : byte absolute OldStr;

BEGIN
Position := Pos (StUpCase (OldStr), StUpCase (S));   { find OldStr }
If Position > 0 then begin                           { if OldStr exists }
  delete (S, Position, OldStrLen);                   { delete it }
  insert (NewStr, S, Position);                      { insert NewStr }
  end;
END;

{ ========================================================================= }

PROCEDURE ReplaceAll (VAR S : string;
                      OldStr, NewStr : string);
{
  Replaces all occurrences of OldStr with NewStr.
}

BEGIN
While Pos (OldStr, S) > 0 do
  ReplaceOnce (S, OldStr, NewStr);
END;

{ ========================================================================= }

PROCEDURE StrOb.Replace (OldStr, NewStr : string);
{
  Finds first occurrence of OldStr, replaces it with NewStr.
}

BEGIN
  ReplaceOnce (S, OldStr, NewStr);
END;

{ ========================================================================= }

PROCEDURE StrOb.Translate (OldCh, NewCh : char);
{
  Finds every occurrence of OldCh, replaces it with NewCh.
}

VAR
  Len  : byte absolute S;
  Loop : byte;

BEGIN
  If OldCh <> NewCh then
    For Loop := 1 to Len do
      If S [Loop] = OldCh then
        S [Loop] := NewCh;
END;

{ ========================================================================= }

PROCEDURE StrOb.Append (NewStr : string);
{
  Adds NewStr to end of S.
}

BEGIN
  S := S + NewStr;
END;

{ ========================================================================= }

PROCEDURE StrOb.AppendWord (NewStr : string);
{
  Adds ' ' and a word to the end of S.
}

BEGIN
  Append (' ' + NewStr);
END;

{ ========================================================================= }

PROCEDURE StrOb.HeadAppend (NewStr : string);
{
  Adds NewStr to the beginning of S.
}

BEGIN
  S := NewStr + S;
END;

{ ========================================================================= }

PROCEDURE StrOb.Compress;
{
  Takes S and compresses it at a ratio of 8:5.  Compression works by
  converting 8-bit ASCII chararcters into 5-bit code.  Only letters
  are unique.  Numbers and punctuation are ignored.  Based on routines
  from Scott Bussinger.
}

VAR
  Len         : byte absolute S;
  I           : word;
  J           : word;
  BitMask     : word;
  ShiftFactor : word;
  ResultStr   : string;

BEGIN
  FillChar (ResultStr, sizeof(ResultStr), 0);    { Initialize result }
  J := 1;
  for I := 1 to Len do begin                     { Pack each char in turn }
    ShiftFactor := (I + I + I) and 7;
    case S[I] of
      '0'..'9'  : BitMask := 27;
      'a'..'z',
      'A'..'Z'  : BitMask := ord (S[I]) and $1F;
    else
      BitMask := 0
      end;  { case }
    BitMask := BitMask shl ShiftFactor;
    ResultStr [J] := chr (ord (ResultStr [J]) or lo (BitMask));
    ResultStr [pred (J)] := chr (ord (ResultStr[pred (J)]) or hi (BitMask));
    if ShiftFactor < 5 then
      inc(J)
    end;
  ResultStr [0] := chr ((5 * Len + 7) shr 3);    { Set new length }
  S := ResultStr
END;

{ ========================================================================= }

PROCEDURE StrOb.DeCompress;
{
  Takes compressed string S and decompresses it at a ratio of 5:8.
  All letters are capitalized.  Numbers and punctuation are blanked.
  May be some extra blanks on end.  Based on routines from
  Scott Bussinger.
}

TYPE
  WordPtr = ^word;

VAR
  Len         : byte absolute S;
  I           : word;
  J           : word;
  ResultStr   : string;
  ShiftFactor : word;

BEGIN
  ResultStr [0] := chr ((8 * Len + 4) div 5);
  FillChar (S [succ (Len)], 255 - Len, 0);
           { In case we have a partially used last byte }
  J := 0;
  for I := 1 to length (ResultStr) do begin      { Get each char in turn }
    ShiftFactor := (I + I + I) and 7;
    ResultStr [I] := chr ((swap (WordPtr (@S[J])^) shr ShiftFactor)
                          and $1F or $40);
    case ResultStr [I] of
      'A'..'Z': ;
    else
      ResultStr[I] := ' ';                       { Blank out odd chars }
      end;
    if ShiftFactor < 5 then
      inc(J);
    end;
  S := ResultStr;
  TrimTrailCh (' ');
END;

{ ========================================================================= }

FUNCTION StrOb.L : byte;
{
  Reports length of S, by returning value in Len.
}

VAR
  Len  : byte absolute S;

BEGIN
  L := Len;
END;

{ ========================================================================= }

FUNCTION StrOb.LastPos (PosCh : char) : byte;
{
  Works like Pos function, but works from right to left.
}

VAR
  Loop : byte;
  Len  : byte absolute S;

BEGIN
  Loop := Len;
  While
    (S [Loop] <> PosCh)
      and
    (Loop > 0)
  do
    dec (Loop);
  LastPos := Loop;
END;

{ ========================================================================= }

FUNCTION GetSubStr (S : string;  Pos1, Pos2 : byte) : string;
{
  Extracts a SubString, starting at Pos1, ending at Pos2.
}

BEGIN
  GetSubStr := Copy (S, Pos1, succ (Pos2) - Pos1);
END;

{ ========================================================================= }

FUNCTION StrOb.SubStr (Pos1, Pos2 : byte) : string;
{
  Extracts a SubString, starting at Pos1, ending at Pos2.
}

BEGIN
  SubStr := GetSubStr (S, Pos1, Pos2);
END;

{ ========================================================================= }

FUNCTION StrOb.ExtractFirstWord : string;        { 8906.01 }
{
  Extracts the first word from a string, and deletes it from the string.
}

VAR
  WordPos  : byte;
  Len      : byte absolute S;

BEGIN
  If Len > 0 then
    begin
    S := Trim (S);
    WordPos := pos (' ', S);
    ExtractFirstWord := SubStr (1, pred (WordPos));
    S := SubStr (succ (WordPos), Len);
    end
  else
    ExtractFirstWord := '';
END;

{ ======================================================================== }

FUNCTION StrOb.TrimThe : string;
{
  Removes 'A', 'An', and 'The' from the beginning of a string.

  CompUCString is a Turbo Professional function.
}

BEGIN
  If CompUCString ('A ', Copy (S, 1, 2)) = Equal then
    delete (S, 1, 2)
  else
    If CompUCString ('AN ', Copy (S, 1, 3)) = Equal then
      delete (S, 1, 3)
    else
      If CompUCString ('THE ', Copy (S, 1, 4)) = Equal then
        delete (S, 1, 4);
  TrimThe := S;
END;

{ ========================================================================= }

FUNCTION  Num2Str (Num : extended) : string;
{
  Num2Str takes any number and returns it as the shortest possible string.
}

VAR
  S        : string;
  Len      : byte absolute S;
  ExpStr   : string [4];
  EPos,
  E        : word;

  FUNCTION TrimStr (S : string) : string;
  {
    Trims spaces, trims '0's, then trims trailing decimal point.
    If first char in S is a decimal point, restores leading 0.
    If S is reduced to '', function returns 0.
  }
  BEGIN
  S := TrimTrailChars (TrimChars (TrimChars (S, ' '), '0'), '.');
  If S [1] = '.' then insert ('0', S, 1);
  If S > '' then TrimStr := S else TrimStr := '0';
  END;

BEGIN
  Str (Num, S);                         { convert to str + E }
  EPos   := Pos ('E', S);               { where is 'E' ? }
  ExpStr := GetSubStr (S, EPos + 2, Len);
  If not Str2Word (ExpStr, E) then      { E := abs value of exponent }
    Num2Str := ''
  else
    If E > 10 then
      Num2Str := TrimStr (GetSubStr (S, 1, Pred (Epos))) +
                 GetSubStr (S, EPos, Succ (EPos)) +       { E + or - }
                 TrimLeadChars (GetSubStr (S, EPos + 2, Len), '0')
    else
      Num2Str := TrimStr (Real2Str (Num, 35, 18));
END;

{ ========================================================================= }

FUNCTION  Str2Num (S : string) : real;
{
  Turns a string into a real.
}

VAR
  R : float;

BEGIN
  If Str2Real (S, R) then
    Str2Num := R
  else
    Str2Num := 0;
END;

{ ========================================================================= }

{$B-}
FUNCTION InAlphabet (Ch : char) : boolean;
{ Returns true if ch in Alphabet. }

BEGIN
  InAlphabet := ((Ch > #96) and (Ch < #123))
                  or
                ((Ch > #64) and (Ch < #91));
END;
{$B+}

{ ========================================================================= }

FUNCTION InNumbers (Ch : char) : boolean;
{ Returns true if ch is a number. }

BEGIN
  InNumbers := (Ch > #47) and (Ch < #58);
END;

{ ========================================================================= }

FUNCTION InApostrophe (Ch : char) : boolean;
{ Returns true if ch is apostrophe. }

BEGIN
  InApostrophe := (Ch = #39);
END;

{ ========================================================================= }

FUNCTION InTwoSpacePunctuation (Ch : char) : boolean;
{ Returns true if ch in two space punctuation. }

BEGIN
  InTwoSpacePunctuation := Pos (Ch, '.!?;:') > 0;
END;

{ ========================================================================= }

FUNCTION InPunctuation (Ch : char) : boolean;
{ Returns true if ch in punctuation. }

BEGIN
  InPunctuation := not InAlphabet (Ch) and
                   not InNumbers (Ch) and
                   not InApostrophe (Ch);
END;

{ ========================================================================= }
{ Initialization }
{ ========================================================================= }

END.

{ ========================================================================= }